
(require "copy-struct.ss")

(define-struct automaton (name accepting? start? parents self children) (make-inspector))


(define (make-table)
  (list '*table*))

(define (blanknode) (make-automaton '() '() '() (make-table) (make-table) (make-table)))

(define q1 (blanknode))
(define q2 (blanknode))
(define q3 (blanknode))
(define q4 (blanknode))
(define q5 (blanknode))


;tables
(define (lookup key table)
  (let ((record (assoc key (rest table))))
    (if record
        (rest record)
        false)))


(define (assoc key records)
  (cond ((empty? records) false)
        ((eq? key (first (first records))) (first records))
        (else (assoc key (rest records)))))

;To insert a value in a table under a specified key, we first use assoc to see if there is already a record in the table with this key. If not, we form a new record by consing the key with the value, and insert this at the head of the table's list of records, after the dummy record. If there already is a record with this key, we set the cdr of this record to the designated new value. The header of the table provides us with a fixed location to modify in order to insert the new record.

(define (insert-link! key value table)
  (let ((record (assoc key (rest table))))
    (if record
        (set-cdr! record (make-union value (rest record)))
        (set-cdr! table
                  (cons (cons key value) (rest table)))))
  'ok)

(define (insert! key value table)
  (let ((record (assoc key (rest table))))
    (if record
        (set-cdr! record value)
        (set-cdr! table
                  (cons (cons key value) (rest table))))))


;filter the table
;remove the link of the deleted node from the relevant former parent and child nodes
(define (remove-link! anode parent child)
  (begin
    (delete-link! anode (automaton-children parent))
    (delete-link! anode (automaton-parents child))))


(define (delete-link! key table)
  (let ((record (assoc key (rest table))))
    (if record
        (set-cdr! table (filter (lambda (x) (not (eq? key (first x)))) (rest table))) 'not_there)))


(define (filter predicate sequence)
  (cond ((null? sequence) empty)
        ((predicate (car sequence))
         (cons (car sequence)
               (filter predicate (cdr sequence))))
        (else (filter predicate (cdr sequence)))))


(define (make-union exp1 exp2)
  (append exp1 '(+) exp2 ))

(define (make-closure exp)
  (if (not (empty? exp))
      (append '(:) exp '(:*))
      empty))



(define (create-link! startnode endnode input)
  (if (eq? startnode endnode) (begin (insert-link! endnode input (automaton-self endnode)))
      (begin (insert-link! endnode input (automaton-children startnode))
             (insert-link! startnode input (automaton-parents endnode))))
  )


(define q0 (blanknode))
(define q1 (blanknode))
(define q2 (blanknode))
(define q3 (blanknode))
(define q4 (blanknode))


(define (create-node! node name isaccepting isstart)
  (set-automaton-name! node name)
  (set-automaton-accepting?! node isaccepting)
  (set-automaton-start?! node isstart)
  )


(define (accumulate proc base alist)
  (cond
    ((empty? alist) base)
    (else
     (proc (first alist) (accumulate proc base (rest alist))))))


(define (enumerate-interval start end)
  (cond 
    ((> start end) empty)
    (else
     (cons start (enumerate-interval (+ 1 start) end)))))



(define (combinations anode)
  (accumulate append
              empty
              (map (lambda (i)
                     (map (lambda (j) (list i j))
                          (rest (automaton-children anode))))
                   (rest (automaton-parents anode)))))


(define (remove-node anode)
  (begin (update-paths anode (combinations anode))))

(define (update-paths currnode paths)
  (cond ((empty? paths) 'done)
        (else
         (let ((parent (get-parent (first paths)))
               (child (get-child (first paths)))
               (path (newpath currnode (first paths))))
           (begin (create-link! 
                   parent
                   child
                   path)
                  (remove-link! currnode parent child))
           (update-paths currnode (rest paths))))))

(define (get-parent apair)
  (first (first apair)))

(define (get-child apair)
  (first (first (rest apair))))

(define (get-self anode)
  (cond ((empty? (rest (automaton-self anode))) empty)
        (else
         (rest (first (rest (automaton-self anode)))))))

(define (newpath anode apair)
  (append (rest (first apair)) (make-closure (get-self anode)) (rest (first (rest apair)))))

(define (test-case node)
  (begin (create-link! node node '(0))
         (create-link! node q4 '(1))
         (create-link! q2 node '(1))
         (remove-node node))
  (if (equal? (cons '*table* (list (cons q2 '(1 : 0 :* 1)))) (automaton-parents q4)) true
      false)
  )


;procedures for copying automatons before states are eliminated.
(define (states-copy somestates)
  (make-states (automaton-copy (states-start somestates)) (automaton-copy (states-accepting somestates)) (automaton-copy (states-intermediate somestates))))

(define (automaton-copy anautomaton)
  (cond ((empty? anautomaton) '())
        (else (cons (copy-struct automaton (first anautomaton)) (automaton-copy (rest anautomaton)))))) 


;blank table for storage of past automatons
(define automaton-history (make-table))


;group the automaton according to the identity of the nodes in the following structure (name is not fixed)

(define-struct states (start accepting intermediate)(make-inspector))

;reduce the automaton by elimintaing nodes
(define (reduce automaton)
  (let ((intermediate-nodes (states-intermediate automaton)))
    
    ;get rid of the intermediate nodes
    (define (pare-it alos iteration)
      (cond 
        ((empty? alos) automaton-history)
        (else 
         (begin
           (insert! iteration (states-copy automaton) automaton-history)
           (remove-node (first alos))
           (pare-it (rest alos) (+ iteration 1))))))
    
    (pare-it intermediate-nodes 1)))




;copy a list of automaton-structures

(define (intermediate? anode)
  (and (= 0 (automaton-start? anode))(= 0 (automaton-accepting? anode))))



(define (make-test-automaton!)
  (create-node! q0 'q0 0 1)
  (create-node! q1 'q1 0 0)
  (create-node! q2 'q2 1 0)
  (create-node! q3 'q3 0 0)
  (create-node! q4 'q4 0 0)
  (create-link! q0 q1 '(B))
  (create-link! q1 q2 '(C))
  (create-link! q1 q3 '(D))
  (create-link! q3 q4 '(no))
  (create-link! q0 q2 '(yes))
  (create-link! q1 q1 '(again))
  (let (( temp (list q0 q1 q2 q3 q4)))
    (make-states (filter (lambda (x) (= (automaton-start? x) 1)) temp) (filter (lambda(x) ( = (automaton-accepting? x ) 1)) temp) (filter (lambda (x) (intermediate? x)) temp)))
  )










